home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 08 - 1992 / 08.02 Jun 92 / Jörg's Folder / array_send.f < prev    next >
Encoding:
Text File  |  1992-01-20  |  4.2 KB  |  195 lines  |  [TEXT/MPS ]
  1. !!M Inlines.f
  2. !!G AEvent.finc
  3. c
  4. c
  5.     program AEMenu
  6.  
  7.     implicit none
  8.     
  9.     external get_reply,send_array
  10.     integer*2 err
  11.     
  12.     err = AEInstallEventHandler (%val('aevt'),%val('ansr'),%val(%loc(get_reply)),%val(int4(0)),%val(int2(0))) 
  13.     if (err. ne. 0) then
  14.         type *,'Error installing Apple event, result code = ',err
  15.     end if
  16.  
  17.     call AddMenuItem ('AE menu','setup array',setup_array)
  18.     call AddMenuItem ('AE menu','send array',send_array)
  19.     call AddMenuItem ('AE menu','show array',show_array)
  20.     
  21.     end
  22.     
  23.     subroutine setup_array
  24.     implicit none
  25.     
  26.     real*4 myarray(10000)
  27.     integer xdim,ydim
  28.     global xdim,ydim,myarray
  29.     
  30.     xdim = 10
  31.     ydim = 15
  32.     call setarray(myarray,xdim,ydim)
  33.     
  34.     return
  35.     end
  36.  
  37.     subroutine setarray(array,xdim,ydim)
  38.     integer xdim,ydim
  39.     real*4 array(xdim,ydim)
  40.     
  41.     do i=1,xdim
  42.         do j=1,ydim
  43.         array(i,j) = 10000.*(i-1) + 1.*(j-1)
  44.         end do
  45.     end do
  46.     
  47.     return
  48.     end
  49.  
  50.     subroutine show_array
  51.     implicit none
  52.     
  53.     real*4 myarray(10000)
  54.     integer xdim,ydim
  55.     global xdim,ydim,myarray
  56.     
  57.     xdim = 10
  58.     ydim = 15
  59.     call display(myarray,xdim,ydim)
  60.     
  61.     return
  62.     end
  63.  
  64.     subroutine display(array,xdim,ydim)
  65.     integer xdim,ydim
  66.     real*4 array(xdim,ydim)
  67.     
  68.     write (*,'(1x,10(1xf7.0))') ((array(i,j),i=1,xdim),j=1,ydim)
  69.     
  70.     return
  71.     end
  72.  
  73.     subroutine send_array
  74.     implicit none
  75.     
  76.     real*4 myarray(10000)
  77.  
  78.     integer xdim,ydim
  79.     global xdim,ydim,myarray
  80.     
  81.     integer totalsize
  82.     
  83.     integer*2 err
  84.     record /AppleEvent/ theAppleEvent,reply
  85.     record /targetID/ target
  86.     record /LocationNameRec/ myLocation
  87.     record /PortInfoRec/ myPortInfo
  88.     record /AEAddressDesc/ targetAddress
  89.     
  90.     err = PPCBrowser(%val(int4(0)),%val(int4(0)),%val(int2(0)),
  91.     1    %ref(myLocation),%ref(myPortInfo),%val(int4(0)),%val(int4(0)))
  92.     if (err    .ne. 0) then
  93.         type *,'PPC Browser: error ',err
  94.         return
  95.     end if
  96.     
  97.     target.location = myLocation
  98.     target.name = myPortInfo.name
  99.     
  100.     type *,'Session ID = ',target.sessionid,', target name = ',target.name.name
  101.     
  102.     err = AECreateDesc(%val(typeTargetID),%val(%loc(target)),
  103.     1                %val(sizeof(target)),%ref(targetAddress))
  104.     if (err    .ne. 0) then
  105.         type *,'AECreateDesc: error ',err
  106.         return
  107.     end if    
  108.     
  109.     err = AECreateAppleEvent(%val('JLMT'),%val('MULT'),%ref(targetAddress),
  110.     1        %val(kAutoGenerateReturnID),%val(int4(kAnyTransactionID)),
  111.     2        %ref(theAppleEvent))
  112.     if (err    .ne. 0) then
  113.         type *,'AECreateAppleEvent: error ',err
  114.         return
  115.     end if    
  116.     
  117.     err = AEPutParamPtr(%ref(theAppleEvent),%val('XDIM'),%val(typeInteger),
  118.     1        %val(%loc(xdim)),%val(sizeof(xdim)))
  119.     if (err    .ne. 0) then
  120.         type *,'AEPutParamPtr: error ',err
  121.         return
  122.     end if    
  123.     
  124.     err = AEPutParamPtr(%ref(theAppleEvent),%val('YDIM'),%val(typeInteger),
  125.     1        %val(%loc(ydim)),%val(sizeof(ydim)))
  126.     if (err    .ne. 0) then
  127.         type *,'AEPutParamPtr: error ',err
  128.         return
  129.     end if    
  130.     
  131.     totalsize = xdim * ydim * 4
  132.     
  133.     err = AEPutParamPtr(%ref(theAppleEvent),%val('ARRY'),%val(typeChar),
  134.     1        %val(%loc(myarray)),%val(totalsize))
  135.     if (err    .ne. 0) then
  136.         type *,'AEPutParamPtr: error ',err
  137.         return
  138.     end if    
  139.     
  140.     err = AESend(%ref(theAppleEvent),%ref(reply),
  141.     1        %val(int4(kAEQueueReply+kAENeverInteract)),
  142.     2        %val(kAENormalPriority), %val(int4(120)), %val(int4(0)),%val(int4(0)) )
  143.     if (err    .ne. 0) then
  144.         type *,'AESend: error ',err
  145.         return
  146.     end if    
  147.     
  148.     type *,'Sent test array of size ',xdim*ydim
  149.  
  150.     return
  151.     end
  152.  
  153.     integer*2 function get_reply(theAppleEvent,reply,%val(handlerRefCon))
  154.     record /AppleEvent/ theAppleEvent
  155.     record /AppleEvent/ reply
  156.     integer*4 handlerRefCon
  157.     
  158.     real*4 myarray(10000)
  159.     integer xdim,ydim
  160.     global xdim,ydim,myarray
  161.     
  162.     integer totalsize
  163.     
  164.     err = AEGetParamPtr(%ref(theAppleEvent),%val('XDIM'),%val(typeInteger),
  165.     1        returnedType,%val(%loc(xdim)),%val(sizeof(xdim)),actualSize)
  166.     if (err    .ne. 0) then
  167.         type *,'AEGetParamPtr: error ',err
  168.         goto 9999
  169.     end if    
  170.     
  171.     err = AEGetParamPtr(%ref(theAppleEvent),%val('YDIM'),%val(typeInteger),
  172.     1        returnedType,%val(%loc(ydim)),%val(sizeof(ydim)),actualSize)
  173.     if (err    .ne. 0) then
  174.         type *,'AEGetParamPtr: error ',err
  175.         goto 9999
  176.     end if    
  177.     
  178.     totalsize = xdim * ydim * 4
  179.     
  180.     err = AEGetParamPtr(%ref(theAppleEvent),%val('ARRY'),%val(typeChar),
  181.     1        returnedType,%val(%loc(myarray)),%val(totalsize),actualSize)
  182.     if (err    .ne. 0) then
  183.         type *,'AEGetParamPtr: error ',err
  184.         goto 9999
  185.     end if    
  186.     
  187.     type *,'Reply received from server'
  188.     
  189.     get_reply = 0    ! noErr
  190.     return
  191.  
  192. 9999    get_reply = err    
  193.         return
  194.     end
  195.